home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Supplement / my stuff / timeManager < prev    next >
Text File  |  1992-10-30  |  4KB  |  121 lines
  1. \ Read IMIV for a description of what this might be used for..care must
  2. \ be taken not to move memory, rely on unlocked handles, etc.
  3. \ Remember to remove tasks prior to exiting the application.
  4.  
  5. hex
  6. create Tinstall ( ptr -- result) popA0 " InsTime" asmcall pushd0 next,
  7. create Tremove  ( ptr -- result) popA0 " rmvTime" asmcall pushd0 next,
  8. create Tprime   ( len ptr -- result) popD0 popA0 " primeTime" asmcall pushd0 next,
  9. create geta5a3 ( -- a5 a3)  2f0d w,  2f0b w, next,
  10.  
  11. 0 value TstartLen
  12.  
  13. \ necessary for Time Manager calls
  14. \ TSTART - Converts Pascal stack format to our Forth stack format.
  15. \            N.B. - VERY IMPORTANT!!! - This word will never be
  16. \            directly executed. Instead the code will be CMOVE'd
  17. \            into place during the execution of TPROC and executed by
  18. \            the routine active via JSR.
  19.  
  20. Create Tstart <[                                    \ a1 points to record
  21.     204e w,            \ movea.l    a6,a0                \ store return stack ptr
  22.     2C4F w,            \ movea.l    a7,a6                \ save parm stack
  23.     9DFC w, 1b58 ,    \ suba.l    #7000,a6            \ allow stack to have 7000 bytes
  24.     2D08 w,            \ move.l    a0,-(a6)            \ save old return stack ptr here
  25.     2D1F w,            \ move.l    (a7)+,-(a6)            \ save return address here
  26.     48E63F1C ,        \ movem.l    d2-d7/a3-a5,-(a6)    \ save these registers, including a5
  27.     2a690012 ,        \ move.l    18(a1),a5            \ get myA5
  28.     26690016 ,        \ move.l    22(a1),a3            \ get myA3
  29.     2A0E w,            \ move.l    a6,d5                \ let ret stack have only 300
  30.     0485 w, 12c ,    \ subi.l    #300,d5                \ and give method stack the rest
  31.     49FA0006 ,        \ lea        6(pc),a4               \ load a4 with ptr to routine
  32. next,
  33.  
  34. \ TEXIT - This code is equally tricky as the above TSTART. This
  35. \          restores the old A6 register and then jumps back to the
  36. \          return location from which the word was called. This
  37. \          code word will be invoked through the colon code, but
  38. \          colon-code will never see it again.
  39. Create T;s <[
  40.     4CDE38FC ,        \ movem.l    (a6)+,d2-d7/a3-a5    \ restore a3 and a5 especially
  41.     205E w,            \ movea.l    (a6)+,a0
  42.     2C5E w,            \ movea.l    (a6)+,a6
  43.     4ED0 w,            \ jmp        (a0)
  44.  
  45. Decimal
  46. ' T;s nfa ' Tstart -  -> TstartLen
  47.  
  48. \ build a word that looks like a Pascal procedure at its PFA
  49. : :TPROC
  50.     ?exec create    \  build hdr, cfa
  51.     ' tstart here tstartLen allot   tstartLen cMove
  52.     cflush    \ flush caches on appropriate machines
  53.     ]> ;    \ enter compilation state
  54.     
  55. : ;TPROC   Compile T;s  [Compile] <[   ;  Immediate
  56.  
  57.  
  58. :CLASS time <super object
  59.  
  60.     var            qlink
  61.     int            qtype
  62.     var            tmAddr
  63.     var            tmCount    \ don't believe IM..this needs to be 4 bytes
  64.     var            tmDelay
  65.     var            myA5
  66.     var            myA3
  67.  
  68. \ once installed, and then removed, you may reInstall using this method
  69.   :M reInstall: ( --) abs: self Tinstall abort" can't start" ;M
  70.  
  71. \ Use this method as the first thing...It loads up the record with values
  72.   :M install: ( cfaProc -- ) geta5a3 put: myA3 put: myA5
  73.     +base >body put: tmAddr reInstall: self ;M
  74.  
  75. \ To remove the task from the queue
  76.   :M remove: ( --) abs: self Tremove abort" can't remove" ;M
  77.  
  78.   :M setDelay: ( n --) put: tmDelay ;M
  79.  
  80.   :M getDelay: ( -- n) get: tmDelay ;M
  81.  
  82. \ start the task...it doesn't repeat, but must be restarted for continuous operation
  83.   :M go: abs: self get: tmDelay Tprime abort" can't start" ;M
  84.  
  85.   :M start: go: self ;M
  86.  
  87.   :M classinit: 1 put: qtype ;M
  88.  
  89. ;CLASS
  90.  
  91.  
  92. \ procedure is to install a TprocWord, set the delay when the TprocWord should execute,
  93. \  and when you want to start timing, say go:
  94. \ When you're completely done, just remove:
  95.  
  96. \ schedule: might change to time: or something. The classname might also change.
  97.  
  98. \ rect suz
  99. \ 100 100 200 200 put: suz
  100. \ 
  101. \ time painter time clearer
  102. \ :tproc paintit pushPort set: fwind  paint: suz  popPort go: clearer ;tproc
  103. \ :tproc clearit pushPort set: fwind  set: fwind clear: suz draw: suz popPort go: painter ;tproc
  104. \ 3000 setdelay: painter
  105. \ 1000 setdelay: clearer
  106. \ 
  107. \ 'c paintit install: painter
  108. \ 'c clearit install: clearer
  109. \ go: painter
  110. \ 
  111. \ : stopthem remove: painter remove: clearer ;
  112.  
  113. \ or another way
  114. \  0 value PaintOrClear
  115. \ :tproc paintit pushPort set: fwind  PaintOrClear IF paint: suz ELSE clear: suz draw: suz THEN
  116. \     PaintOrClear 1 xor -> PaintOrClear popPort go: painter ;tproc
  117. \  'c paintit install: painter
  118. \  go: painter
  119.  
  120.  
  121.